home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The CICA Windows Explosion!
/
The CICA Windows Explosion! - Disc 2.iso
/
programr
/
iceb3r1.zip
/
ctl3d.bas
next >
Wrap
BASIC Source File
|
1995-05-01
|
7KB
|
183 lines
Option Explicit
' CTL3DV2 functions
Declare Function Ctl3dAutoSubclass Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dRegister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dUnregister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3DSubClassDlgEx Lib "Ctl3DV2.DLL" (ByVal hInst As Integer, ByVal Flags As Long) As Integer
Declare Function Ctl3dSubclassCtlEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, ByVal CntrlType As Integer) As Integer
' CTL3DV2 constants
Global Const CTL3D_BUTTON_CTL = 0
Global Const CTL3D_LISTBOX_CTL = 1
Global Const CTL3D_EDIT_CTL = 2
Global Const CTL3D_COMBO_CTL = 3
Global Const CTL3D_STATIC_CTL = 4
' API routines
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nOffset As Integer) As Integer
Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
' API Constants
Global Const GWW_HINSTANCE = -6
Global Const GWL_STYLE = -16
Global Const DS_MODALFRAME = &H80&
' Frame types
Global Const SS_BLACKFRAME = &H7&
Global Const SS_GRAYFRAME = &H8&
Global Const SS_WHITEFRAME = &H9&
Global Const WINDOW_BACKGROUND = &H80000005 ' Window background.
Global Const BUTTON_FACE = &H8000000F ' Face shading on command buttons.
Global Const BUTTON_SHADOW = &H80000010 ' Edge shading on command buttons.
Global Const DONT_SUBCLASS = -1
Global hInstance As Integer
' Again we MUST use the instance handle not the
' Module handle. See InitCTL3D for details
Sub End3D ()
Dim iResult As Integer
' Unregister with CTL3D
iResult = Ctl3dUnregister(hInstance)
End Sub
' Get the Instance Handle for this program. It MUST be used in place
' of the Module Handle to ensure programs running more than once
' will work correctly
Function GetInstance (oFrm As Form)
GetInstance = GetWindowWord(oFrm.hWnd, GWW_HINSTANCE)
End Function
' Show a ThreeD dialog
Sub Make3D (Frm As Form)
Dim iResult As Integer, iCTRL As Integer
Dim iType As Integer, bColour As Integer, cLabel As String
Dim lStyle As Long
If Frm.BorderStyle = 3 Then
' Set the Windows style bits to make CTL3D paint
' the border as well as the client area
lStyle = GetWindowLong((Frm.hWnd), GWL_STYLE)
lStyle = lStyle Or DS_MODALFRAME
lStyle = SetWindowLong((Frm.hWnd), GWL_STYLE, lStyle)
End If
Frm.BackColor = BUTTON_FACE
' Activate CTL3D for this window, since VB doesn't use true
' Dialogs you must tell it to do it yourself
iResult = Ctl3DSubClassDlgEx((Frm.hWnd), 0&)
' Since VB has already subclassed the controls to 'THUNDER' controls
' CTL3D will not touch them. So we must walk through the controls and
' tell it what class to subclass them as
For iCTRL = 0 To Frm.Controls.Count - 1
' Start by assuming we won't subclass the control
iType = DONT_SUBCLASS
' Used to store a fake label used in frames
cLabel = ""
' and not change it's back color
bColour = False
' Lets find the type of the control
If TypeOf Frm.Controls(iCTRL) Is OptionButton Then
' Colour it and Subclass it as a button
bColour = True
iType = CTL3D_BUTTON_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is CheckBox Then
' Colour it and Subclass it as a button
bColour = True
iType = CTL3D_BUTTON_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is CommandButton Then
' Colour it and Subclass it as a button
bColour = True
iType = CTL3D_BUTTON_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is ListBox Then
' Colour it and Subclass it as a listbox
bColour = True
iType = CTL3D_LISTBOX_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is FileListBox Then
' Colour it and Subclass it as a listbox
bColour = True
iType = CTL3D_LISTBOX_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is DirListBox Then
' Colour it and Subclass it as a listbox
bColour = True
iType = CTL3D_LISTBOX_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is PictureBox Then
' for picture boxes i've decided to only subclass
' if there is a border, otherwise I set it's back colour
' This gives white 3D pictures or a grey panel which
' can be used to group controls such as OptionButtons
If Frm.Controls(iCTRL).BorderStyle Then
iType = CTL3D_LISTBOX_CTL
Else
bColour = True
End If
If Frm.Controls(iCTRL).Tag <> "" Then
cLabel = Frm.Controls(iCTRL).Tag
End If
ElseIf TypeOf Frm.Controls(iCTRL) Is TextBox Then
' Don't color text boxes but Subclass them as Edit controls
iType = CTL3D_EDIT_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is ComboBox Then
' Don't color ComboBoxes but subclass them as COMBO controls
iType = CTL3D_COMBO_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is DriveListBox Then
' Don't color DriveListBoxes but subclass them as COMBO controls
iType = CTL3D_COMBO_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is Frame Then
' Colour and Subclass them as Buttons controls
' Yes, windows calls Frames buttons!
bColour = True
iType = CTL3D_BUTTON_CTL
ElseIf TypeOf Frm.Controls(iCTRL) Is Label Then
' Colour but don't subclass a label
bColour = True
End If
' Set the BackColor as required
If bColour Then
Frm.Controls(iCTRL).BackColor = BUTTON_FACE
End If
' Produce a fake label that will survive a 3D Frame
If cLabel <> "" Then
Frm.Controls(iCTRL).Print cLabel
End If
' Subclass the control as required
If iType <> DONT_SUBCLASS Then
' Pass it the Controls hWnd and type type required
iResult = Ctl3dSubclassCtlEx((Frm.Controls(iCTRL).hWnd), iType)
End If
Next
' Display the form, I'm using Modal in this example but it's not required
Frm.Show 1
End Sub
' Call this routine from the MouseUp event of the OptionButton
' to ensure you the 3D painting is correct.
Sub PaintRadio (obWas As OptionButton, obNew As OptionButton)
' Repaint the control being activated
obNew.Refresh
' We must do it twice to ensure the focus rect
' is painted correctly (It doesn't work with one!)
obNew.Refresh
' If these are two different controls then update
' the one that used to be set
If obWas.hWnd <> obNew.hWnd Then
' Only one update is required for this one
' since it doesn't have the focus
obWas.Refresh
End If
End Sub
' Register with CTL3D. You must register with an instance
' handle NOT the module handle, you will cause GPF's when
' running multiple instances of your program.
Sub Start3D ()
Dim iResult As Integer
' Register with CTL3D
iResult = Ctl3dRegister(hInstance)
If iResult Then
' Make MSGBoxes and Common dialogs 3D
iResult = Ctl3dAutoSubclass(hInstance)
End If
End Sub